home *** CD-ROM | disk | FTP | other *** search
/ Delphi 2.0 - Programmer's Utilities Power Pack / Delphi 2.0 Programmer's Utilities Power Pack.iso / s_to_z / xbformat / xbformat.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1996-09-15  |  48.0 KB  |  1,318 lines
  1. {$X+}
  2. { XBFORMAT.PAS - Support Xbase file structures
  3.  
  4. Xphiles(tm) source code
  5. Copyright (c) 1995 - 1996 by Interface Technologies
  6. All Rights Reserved Worldwide
  7.  
  8. }
  9. unit XbFormat;
  10.  
  11. interface
  12.  
  13. uses Classes, XbConst, SysUtils, Dialogs;
  14.  
  15. const
  16.  
  17.    DBFFieldTypes = [ 'B', 'C', 'D', 'F', 'G', 'I', 'L', 'M', 'N', 'P', 'T',
  18.       'V', 'Y' ];
  19.    { Index file constants }
  20.    _NTX_MAX_KEY      = 255;          { Maximum length of NTX key expression }
  21.    _NDX_MAX_KEY      = 487;          { Maximum length of NDX key expression }
  22.    _CDX_BLK_SIZE        = 512;            { Size of CDX blocks }
  23.  
  24.    { MDX File constants }
  25.    MDX_SIGNATURE     = 2;           { type code for .mdx file }
  26.  
  27. {   MDX_PAGELEN       = 512;         { length in bytes of a page            }
  28.  
  29.    MDX_DESCENDING    = $08;         { index is descending                  }
  30.    MDX_TAGFIELD      = $10;         { shows tag is a field in file         }
  31.    MDX_UNIQUE        = $40;         { index excludes duplicate keys        }
  32.  
  33. {   MDX_BLOCKHEADLEN  = 8;           { header length of index body block    }
  34.  
  35.    MDX_FLAG_DESCENDING  = $0008;
  36.    MDX_FLAG_FIELDTAG    = $0010;
  37.    MDX_FLAG_UNIQUE        = $0040;
  38.  
  39.    { HiPer SIx / NSX file constants }
  40.    _NSX_PAGE_LEN        = 1024;            { Size of pages }
  41.    _NSX_MIDKEY_CHECK    = 10;                { Insert threshhold for mid-key check }
  42.    _NSX_TAG_MAX        = 11;                { Max length of tag name }
  43.    _NSX_MAX_TAGS        = 50;                { Max number of tags per file }
  44.    _NSX_MAX_KEY        = 256;            { Max key expression length }
  45.  
  46.    { NSX RYO masks }
  47.    _NSX_PARTIAL        = $0100;           { Partial index }
  48.    _NSX_TEMPLATE        = $0200;           { 0x0200 }
  49.    _NSX_CHANGES_ONLY    = $0400;         { Only record changes only }
  50.    _NSX_NO_UPDATE        = $0800;         { Don't update when records change }
  51.    _NSX_SHADOW            = $1000;         { 0x1000 }
  52.  
  53.    { FRM file constants }
  54.    _FRM_EXP_COUNT       = 55;                { Max # of expressions }
  55.    _FRM_MAX_EXPR     = 1440;            { Total bytes for form expressions }
  56.    _FRM_MAX_FIELDS   = 25;                { Max # of columns in a form }
  57.  
  58.    { LBL file constants }
  59.    _LBL_COUNT        = 15;          { 0 .. 15, label line entries }
  60.    _LBL_SIZE         = 59;          { 0 .. 59, 60 chars for contents }
  61.  
  62.     { DBF signature bytes }
  63.    _DBF_FOXBASE      = $02;         { FoxBase, no memo }
  64.     _DBF_NO_MEMO        = $03;            { dBASE III+ }
  65.     _DBF_ENCRYPT        = $06;            { Apollo encrypted, no memo }
  66.    _DBF_VFP          = $30;         { Visual FoxPro }
  67.    _DBF_DB4_SQL      = $43;         { dBASE IV SQL table, no memo }
  68.    _DBF_DB4_SQLSYS   = $63;         { dBASE IV SQL system file, no memo }
  69.     _DBF_DBT_MEMO      = $83;         { CA-Clipper/dBASE III+ .DBT memo }
  70.     _DBF_DBT_ENCRYPT    = $86;            { Apollo encrypted, no memo }
  71.     _DBF_DB4_MEMO        = $8B;         { dBASE IV .DBT memo }
  72.    _DBF_DB4_SQLMEMO  = $CB;         { dBASE IV SQL table, memo }
  73.     _DBF_SMT_MEMO        = $E5;            { HiPer SIx with memo }
  74.     _DBF_SMT_ENCRYPT    = $E6;            { HiPer SIx with memo, encrypted }
  75.     _DBF_FPT_MEMO        = $F5;         { FoxPro .FPT memo }
  76.     _DBF_FPT_ENCRYPT    = $F6;         { Apollo encrypted, FoxPro memo }
  77.    _DBF_FOX_MEMO     = $FB;         { FoxBASE memo }
  78.  
  79.    _DBT4_VERSION     = $0102;       { dBASE IV v1.0 and 1.5 }
  80.  
  81. type
  82.  
  83.    xbMemoType   = ( xbDB3, xbDB4, xbFPT, xbSMT );
  84.  
  85.    EXbFormatError = class( Exception );
  86.  
  87.    DBFHeaderRec = packed record     { DBF File header record, 32 bytes}
  88.       iSignature  : byte;            { Type of memo file used (see constants) }
  89.       iYear       : byte;            { Last update (YMD), Year part }
  90.       iMonth      : byte;            { Last update (YMD), Month part }
  91.       iDay        : byte;            { Last update (YMD), Day part }
  92.       lRecords    : longint;         { # of records in the file }
  93.       wDataOffset : word;            { Data offset (Least significant byte first) }
  94.       wRecLen     : word;            { Length of a record }
  95.       wFiller     : word;           { 2 unused bytes (should be 0s) }
  96.       bIncomplete : boolean;        { Incomplete dBASE IV Transaction? }
  97.       bEncrypted  : boolean;        { dBASE IV Encryption flag }
  98.       sMultiuser  : string[11];     { 12 bytes for multi-user processing }
  99.       iFlags      : boolean;        { Table flags:
  100.                                        $01 = file has production .MDX / .CDX
  101.                                        $02 = file has memos (VFP)
  102.                                        $04 = file is a Database (.DBC) - (VFP) }
  103.       iLanguage   : byte;           { Language driver ID, code page }
  104.       wFiller2    : word;           { 2 unused bytes (should be 0s) }
  105.    end; { DBFHeaderRec }
  106.  
  107.    DBFieldEnd = packed record       { dBASE IV, FoxPro field modifications }
  108.       iFlags      : byte;           { VFP Field Flags:
  109.                                        $01 System Column (not visible to user)
  110.                                        $02 Column can store null values
  111.                                        $04 Binary column (Char or Memo only) }
  112.       cFiller1    : byte;           { 1 unused bytes }
  113.       iWorkArea   : byte;           { Work area }
  114.       sFiller2    : string[9];      { 10 unused bytes }
  115.       bProduction : boolean;        { Production .MDX field flag }
  116.    end; { DBFieldEnd }
  117.  
  118.    DBFieldRec = packed record       { DBF File field header record, 32 bytes }
  119.       szName : array [ 0..10 ] of char;   { Field name }
  120.       case cFieldType : char of           { Field Type }
  121.          'C' :
  122.             ( lPlacement   : longint;     { Field placement (VFP) }
  123.               wCharLen     : word;        { Length of character field }
  124.               recInfo      : DBFieldEnd ); { For Visual dBASE, VFP }
  125.          'B', 'D', 'T', 'F', 'G', 'L', 'M', 'N', 'Y', 'I', 'P':
  126.             ( lPlacement2  : longint;     { Field placement (VFP) }
  127.               iLength      : byte;        { Length of field }
  128.               iDecimal     : byte;        { Decimals of field }
  129.               recInfo1      : DBFieldEnd ); { For Visual dBASE, VFP }
  130.  
  131.    end; { DBFieldRec }
  132.  
  133.    DBT3HeaderRec = packed record    { dBASE III+/CA-Clipper memo file header }
  134.       lBlocks  : longint;           { # of blocks used, including header }
  135.       szFiller : array [ 0..507 ] of char; { 508 unused characters }
  136.    end; { DBT3HeaderRec }
  137.  
  138.    DBT4HeaderRec = packed record    { dBASE IV and up header }
  139.       lNextBlock  : longint;        { Next free block to be used }
  140.       lCurBlockSz : longint;        { Size of current block (0 in v1.0 - 1.5 ) }
  141.       szDBFName   : array [ 0..8 ] of char; { Associated .DBF file name }
  142.       cFiller1    : byte;           { 1 Reserved byte }
  143.       wVersion    : word;           { $102 in v1.0 - 1.5 }
  144.       wBlockSize  : word;           { Block size being used, in K }
  145.       bEncrypted  : boolean;        { Is file encrypted? }
  146.       cFiller2    : char;           { 1 unused char }
  147.    end; { DBT4HeaderRec }
  148.  
  149.    SMTHeaderRec = packed record     { HiPer SIx memo file header }
  150.       lNextBlock  : longint;        { Next free block to be used }
  151.       lBlockSize  : longint;        { Block size being used, in bytes }
  152.       sWasted     : array[ 0..503 ] of char;  { 504 Unused characters }
  153.    end; { SMTHeaderRec }
  154.  
  155.    FPTHeaderRec = packed record     { FoxPro memo file header }
  156.       lNextBlock  : longint;        { Next free block to be used, byte reversed }
  157.       lBlockSize  : longint;        { Block size being used, byte reversed }
  158.       sWasted     : array[ 0..503 ] of char;  { 504 Unused characters }
  159.    end; { FPTHeaderRec }
  160.  
  161.    FPTBlockRec = packed record      { FoxPro memo file block }
  162.       lDataType   : longint;        { Type of data in block }
  163.       lLength     : longint;        { Length of memo entry, in bytes }
  164.       pBuffer     : pointer;
  165.       { Memo text (or data), where n equals the length of the memo entry plus
  166.        the eight byte record header.  The pointer is not really part of the
  167.        structure -- it has to be allocated and assigned to the data immediately
  168.        following lLength }
  169.    end; { FPTBlockRec }
  170.  
  171.    NTXHeaderRec = packed record     { NTX File header, 278 bytes }
  172.        wSign          : word;            { Value 03 for Clipper file }
  173.        wVersion       : word;            { Version of Clipper indexing system }
  174.        lRootPage      : longint;         { Offset to the first index page }
  175.        lNextPage      : longint;        { Offset to first unused page }
  176.        wItemSize      : word;            { Size of the index key + two longs }
  177.        wKeySize       : word;            { Size of the index key value }
  178.        wKeyDec        : word;            { Decimal places for numeric index }
  179.        wMaxItem       : word;            { Maximum # of keys per page }
  180.        wHalfPage      : word;            { Half of MaxItem }
  181.                                      { Index key expression }
  182.        szExpression   : array[ 0.._NTX_MAX_KEY ] of char;
  183.        wUnique        : word;            { Unique ON=1 OFF=0 }
  184.    end; { NTXHeaderRec }
  185.  
  186.    NDXHeaderRec = packed record     { NDX File header, 512 bytes }
  187.        lStartKeyPage  : longint;        { Record # of root page }
  188.        lTotalPages    : longint;        { # of 512 byte pages in file }
  189.        lFiller1       : longint;        { Four unused bytes }
  190.        wKeySize       : word;            { Size of the index key }
  191.        wMaxItem       : word;            { Maximum # of keys per page }
  192.        wKeyType       : word;            { 01 = Numeric, 00 = char }
  193.        wSizeKeyRec    : word;            { Size of an NDX_KEY_REC }
  194.        cFiller2       : char;            { one byte of unused space }
  195.        bUnique        : boolean;        { Unique ON=1, OFF=0 }
  196.                                                 { Index key expression }
  197.        szExpression   : array[ 0.._NDX_MAX_KEY ] of char;    
  198.    end; { NTXHeaderRec }
  199.  
  200.    FRMFieldRec = packed record      { FRM field header }
  201.          iWidth            : shortint;        { Print width of field }
  202.          sFiller1            : string[ 2 ]; { 3 bytes of filler }
  203.          cTotal            : char;             { Should numbers be totaled? }
  204.          iDec                : shortint;        { # of Decimal places }
  205.          iExpContents    : shortint;        { Exp # for field's contents }
  206.          iExpHeader        : shortint;        { Exp # for field's header }
  207.     end; { FRMFieldRec }
  208.  
  209.     FRMHeaderRec = packed record     { FRM file header }
  210.         iSign1            : shortint;        { value 02 indicates a FRM file }
  211.         iExpEnd            : shortint;        { Next free char in ExpArea }
  212.                                     { Array of exp lengths }
  213.         aiExpLength    : array [ 1.._FRM_EXP_COUNT ] of shortint;
  214.                                                 { Indices into ExpArea for start of exp }
  215.         aiExpIndex     : array [ 1.._FRM_EXP_COUNT] of shortint;
  216.                                                  { Container for expressions indexed by
  217.                                                   above arrays }
  218.          pExpArea       : array [ 0.._FRM_MAX_EXPR - 1 ] of char;
  219.                                                 { Array of FRMFields. First is unused. }
  220.         aFields        : array [ 1.._FRM_MAX_FIELDS ] of FRMFieldRec;
  221.         iTitle            : shortint;        { Exp number of title string }
  222.         iGrpOn            : shortint;        { GROUP ON exp number }
  223.         iSubOn            : shortint;        { SUB GROUP ON exp number }
  224.         iGrpHead            : shortint;        { Exp # of GROUP ON heading }
  225.         iSubHead            : shortint;        { Exp # of SUB GROUP ON heading }
  226.         iPageWidth        : shortint;        { Width of page }
  227.         iLinesPerPage    : shortint;        { # of lines per page }
  228.         iLeftMargin        : shortint;        { Left margin }
  229.         iRightMargin    : shortint;        { Right margin }
  230.         iColCount        : shortint;        { # of columns }
  231.          cDoubleSpace    : char;             { Y if doublespaced, N if not }
  232.          cSummary            : char;             { Y if summary, N if not }
  233.          cEject            : char;             { Y if eject page after group, or N }
  234.          iPlusBytes        : byte;             { bit 0=1: EJECT BEFORE PRINT }
  235.                                                  { bit 1=1: EJECT AFTER PRINT }
  236.                                                  { bit 2=1: PLAIN report }
  237.         iSign2            : shortint;        { value 02 }
  238.     end; { FRMHeaderRec }
  239.  
  240.    LBLFieldRec = array[ 0.._LBL_SIZE ] of char;
  241.  
  242.    LBLHeaderRec = packed record     { Label file header }
  243.       iSignature     : byte;        { Signature byte - should be 1 }
  244.                                     { Description of label file }
  245.        szRemarks      : array [ 0..59 ] of char;
  246.       iHeight        : shortint;    { Height of label }
  247.        iWidth         : shortint;    { Width of label }
  248.        iLeftMargin    : shortint;    { Left margin }
  249.       iLabelLine     : shortint;    { Length of label line }
  250.       iLabelSpace    : shortint;    { Space between labels }
  251.       iLabelsAcross  : shortint;    { # of labels across }
  252.        aInfo          : array [ 0.._LBL_COUNT ] of LBLFieldRec;
  253.        iSignature2    : byte;        { Same as iSignature }
  254.    end; { LBLHeaderRec }
  255.  
  256.     MEMVarRec = packed record        { Memory variable file structure }
  257.                                                 { Variable name }
  258.           szVarName        : array [ 0..10 ] of char;    
  259.           cType                : char;            { Type of variable }
  260.           lFiller1            : longint;        { 4 unused bytes }
  261.           iLen                : byte;            { Length of data for variable }
  262.           iDec                : byte;            { Decimal precision }
  263.           sFiller2            : string[ 14 ];{ Second filler region }
  264.     end; { MEMVarRec }
  265.  
  266.     CDXNodeHeadRec = packed record   { CDX file node header }
  267.        iNodeAttribute    : shortint;        { 0: Index, 1: Root, 2: Leaf }
  268.        iNKeys            : shortint;     { Number of keys in node }
  269.        lLeftNode        : longint;      { Offset of left sibling (-1, not present) }
  270.        lRightNode        : longint;      { Offset of right sibling (-1, not present) }
  271.     end; { CDXNodeHeadRec }
  272.  
  273.    { dBASE MDX date stamp }
  274.  
  275.    MDXDate = packed record
  276.       iYear    : byte;
  277.       iMonth   : byte;
  278.       iDay     : byte;
  279.    end; { MDXDate }
  280.  
  281.    { first 48 bytes of an .mdx file   }
  282.  
  283.    MDXHeader = packed record
  284.       iFileType     : byte;         { error if not MDXTYPE }
  285.       LastIndex     : MDXDate;      { last reindex date }
  286.                                     { root name of associated .dbf }
  287.       szRootDBF     : array [0..15 ] of char;
  288.       iBlockSize    : integer;      { SET BLOCKSIZE value, minimum = 2 }
  289.       iBlockBytes   : smallint;      { block size in bytes }
  290.       bProduction   : boolean;      { True if production .mdx, else False }
  291.       sFiller       : string[2];    { 3 unused bytes }
  292.       iIndexCount   : smallint;      { number of indexes in the file }
  293.       iFiller       : smallint;      { 2 unused bytes }
  294.       lEndFilePage  : longint;      { unsigned: page number of end of file }
  295.       lNextFreePage : longint;      { unsigned: page number of next free block }
  296.       lFreePages    : longint;      { unsigned: pages in next free block }
  297.       Created       : MDXDate;      { file creation date }
  298.       cFiller       : byte;         { 1 unused byte }
  299.    end; { MDXHeader }
  300.  
  301.    { An MDX index tag description }
  302.  
  303.    MDXTagDesc = packed record
  304.       lIndHeaderPage : longint;     {  page number of index header }
  305.                                     {  MDX tag name, null-terminated }
  306.       szTagName      : array [ 0..10 ] of char;
  307.       iTagIsField    : byte;        {  10 if the tag is a field, else 0 }
  308.                                     { usage counters }
  309.       aCounters      : array [ 0..3 ] of byte;
  310.       iFiller        : byte;        { 1 unused byte filler, always 02 }
  311.       cKeyType       : char;        { C, D, or N for key type }
  312.       sFiller        : string[11];  { 12 unused bytes }
  313.    end; { MDXTagDesc }
  314.  
  315.    { header of an index }
  316.  
  317.    MDXTagHeader = packed record
  318.       lRootPage   : longint;  { Unsigned: page number of index root }
  319.       lPagesUsed  : longint;  { Unsigned: pages used by the index }
  320.       iFlags      : byte;     { Index status flags: see MDX_FLAG constants }
  321.       cKeyType    : char;     { C, D or N for key type }
  322.       bSQL        : boolean;  { True if optimized for SQL, else False }
  323.       cFiller     : byte;     { 1 unused character }
  324.       wKeyLength  : word;     { length of key in bytes }
  325.       lMaxNodes   : longint;  { unsigned: maximum nodes in a block }
  326.       wRecLen     : word;     { length of an index record in bytes   }
  327.       wChanges    : word;     { change counter for optimization }
  328.       cFiller2    : byte;     { 1 unused character }
  329.       iUniqueFlag : smallint;  { $40 if UNIQUE, else 0 }
  330.                               { The index key expression }
  331.       szKeyExp    : array [ 0..100 ] of char;
  332.    end; { MDXTagHeader }
  333.  
  334.     CDXNodeInfoRec = packed record   { CDX file node information }
  335.        iFreeSpace        : shortint;        { # of bytes available in node }
  336.        lRecNumMask        : word;            { Record number mask }
  337.        iDupByteCnt        : byte;            { Duplicate byte mask count }
  338.        iTrailByteCnt    : byte;            { Trailing byte mask count }
  339.        iRecNumLen        : byte;            { # of bits used for record number }
  340.        iDupCntLen        : byte;            { # of bits used for duplicate count }
  341.        iTrailCntLen    : byte;            { # of bits used for trailing blank count }
  342.        iInfoLen            : byte;            { # of bytes used for record number }
  343.     end; { CDXNodeInfoRec }
  344.  
  345.     CDXTagHeadRec = packed record    { CDX Tag header }
  346.        lRoot                : longint;         { Offset of root block }
  347.        lFree_list        : longint;         { Start of the free list (-1 if none) }
  348.        lLength            : longint;         { Length of file (non-compact only) }
  349.        iKeyLen            : shortint;        { Key Length }
  350.        ucTypeCode        : byte;             { 0x01: Unique; 0x02, 0x04: RYO; 0x08:
  351.                                                  Conditional 0x20: Compact; 0x60: Compound }
  352.     end; { CDXTagHeadRec }
  353.  
  354.     CDXTagRec = packed record        { CDX Tag entry }
  355.         iKeyOn            : shortint;        { Current key # (0 - based) }
  356.                                     { Current key data (10 bytes for tag name
  357.                                        + null) }
  358.         szKey                : array [ 0..10 ] of char;
  359.         pCurPos            : pointer;        { Pointer to current position in data }
  360.         iKeyLen            : shortint;        { Key length }
  361.         sHeader            : CDXNodeHeadRec;    { Node header }
  362.         sNodeInfo        : CDXNodeInfoRec;    { Node info }
  363.         caData            : array [ 0.._CDX_BLK_SIZE - ( sizeof( CDXNodeHeadRec )
  364.                                 + sizeof( CDXNodeInfoRec ) ) ] of char; { Data }
  365.     end; { CDXTagRec }
  366.  
  367.    TDBField = class
  368.    private
  369.    protected
  370.       sName    : string;
  371.       cType    : char;
  372.       iLength  : smallint;
  373.       iDecimal : smallint;
  374.  
  375.       function GetName : string;
  376.       procedure SetName( sNew : string );
  377.       function GetType : char;
  378.       procedure SetType( cNew : char );
  379.       function GetLength : smallint;
  380.       procedure SetLength( iNew : smallint );
  381.       function GetDecimal : smallint;
  382.       procedure SetDecimal( iNew : smallint );
  383.    public
  384.       property FieldName : string read GetName write SetName;
  385.       property FieldType : char read GetType write SetType;
  386.       property FieldLength : smallint read GetLength write SetLength;
  387.       property FieldDecimal : smallint read GetDecimal write SetDecimal;
  388.       function TypeWord : string;
  389.       constructor Create(           { Create the field entry }
  390.          sFieldName     : string;   { Name of the field }
  391.          cFieldType     : char;     { Character type code for the field }
  392.          iFieldLength   : smallint;  { Length of the field }
  393.          iFieldDecimal  : smallint   { Decimal precision for numeric fields }
  394.          );
  395.         function IsMemo    : boolean;    { Is field stored in memo file? }
  396.       function Header   : DBFieldRec;
  397.    end; { TDBField }
  398.  
  399.    TDBStruct = Class( TList )
  400.    private
  401.    protected
  402.       iBlockSize  : smallint;        { Memo file block size }
  403.       function GetField(
  404.          Index    : smallint          { Index of entry to get }
  405.          )        : TDBField;        { Returns the relevant TDBField }
  406.       procedure PutField(
  407.          Index    : smallint;         { Index of entry to put }
  408.          oField   : TDBField );      { TDBField object to put }
  409.       function MakeMemoHeader(      { Write a memo header structure to file }
  410.          sFile    : string;         { Name of memo file }
  411.          const Header;              { Header structure to write }
  412.          iSize    : longint         { Size of header structure }
  413.          )        : boolean;        { True if successful }
  414.       function MakeDBT3(            { Create dBASE III+/CA-Clipper memo file }
  415.          sFile    : string          { Name of DBF file }
  416.          )        : boolean;
  417.       function MakeDBT4(            { Create dBASE IV and up memo file }
  418.          sFile    : string          { Name of DBF file }
  419.          )        : boolean;
  420.       function MakeSMT(             { Create a HiPer SIx memo file }
  421.          sFile    : string          { Name of DBF file }
  422.          )        : boolean;
  423.       function MakeFPT(             { Create a FoxPro memo file }
  424.          sFile    : string          { Name of DBF file }
  425.          )        : boolean;
  426.       function MakeMemo(            { Create the memo file for the DBF }
  427.          sFile    : string          { Name of DBF file }
  428.          )        : boolean;
  429.       function GetBlockSize : smallint;
  430.       procedure SetBlockSize(       { Set the block size }
  431.          iNew : smallint );
  432.    public
  433.       bEncrypt    : boolean;        { Encrypt the file? }
  434.       sDriver     : string;         { Name of the driver to use }
  435.       procedure Free;
  436.       procedure Eval(                { Iterate through structure }
  437.          cbProc   : xbBlockProc        { Data type for "code block" }
  438.          );
  439.       function Make(                { Create the DBF file }
  440.          sFile    : string          { DBF file name }
  441.          )        : boolean;        { True if successful }
  442.       property BlockSize : smallint read GetBlockSize write SetBlockSize;
  443.       function TableType : xbMemoType; { Type of Driver for Table }
  444.       function Signature : byte;    { Signature byte for DBF }
  445.       function HasMemo : boolean;   { Is there a memo field in the DBF? }
  446.       function DataOffset : smallint; { Position of first record in file }
  447.       function RecordLength : smallint; { # of bytes per record }
  448.       property Fields[ Index : smallint ] : TDBField read GetField
  449.          write PutField;
  450.       constructor Create;
  451.    end;  { TDBStruct class }
  452.  
  453. function DBFieldCount(           { # of fields in data file }
  454.    recDBF   : DBFHeaderRec       { Database file header }
  455.    )        : smallint;
  456.  
  457. function dbCreateStruct(         { Convert array of const to DBStruct }
  458.    aStruct  : array of const     { Field structure information:
  459.                                      4 array elements per field:
  460.                                      1. Field name (string)
  461.                                      2. Field type (char)
  462.                                      3. Field length (smallint)
  463.                                     4. Field decimal (smallint) }
  464.    ) : TDBStruct;                { Use TDBStruct.Free when done! }
  465.  
  466. function DBStructRead(           { Read the structure from a DBF file }
  467.    sFile    : string
  468.    )        : TDBStruct;
  469.  
  470. function DBFileType(             { DBF File Type }
  471.    iSignature  : byte            { Signature byte }
  472.    )           : string;
  473.  
  474. procedure ShowDBF(               { Show structure of an DBF file }
  475.    sFile : string );             { Name of DBF file }
  476.  
  477. procedure ShowDBT3(              { Show structure of a DBT3 file }
  478.    sFile : string );             { Name of DBT file }
  479.  
  480. procedure ShowDBT4(              { Show structure of a DBT4 file }
  481.    sFile : string );             { Name of DBT file }
  482.  
  483. procedure ShowSMT(               { Show structure of an SMT file }
  484.    sFile : string );             { Name of SMT file }
  485.  
  486. procedure ShowFPT(               { Show structure of an FPT file }
  487.    sFile : string );             { Name of FPT file }
  488.  
  489. {$IFNDEF XP_NO_NATIVE_DBCREATE}
  490. function dbCreate(               { Create a data file }
  491.    sDataFile   : string;         { Name of data file to create }
  492.    oStruct     : TDBStruct;      { Database structure object }
  493.     sDriver     : string;         { Name of data driver to use for creation }
  494.    bEncrypt    : boolean         { Encrypt the file? }
  495.    ) : boolean;
  496. {$ENDIF}
  497.  
  498. function dbHeaderRead(           { Read in a header from a file }
  499.    sFile       : string;         { Name of file to read }
  500.    var Header;                   { Header structure to read }
  501.    iSize       : smallint         { Size of header structure }
  502.    )           : boolean;        { True if read successfully }
  503.  
  504. implementation
  505.  
  506. { Miscellaneous utility functions culled from other files }
  507. function AllTrim( sTrim : string ) : string;
  508. const
  509.    WhiteSpace = [ #9, ' ', #0, #255 ];
  510. var
  511.    iFront,
  512.    iBack    : integer;
  513. begin
  514.    iFront := 1;
  515.    iBack    := Length( sTrim );
  516.    while ( iFront < iBack ) and ( sTrim[ iFront ] in WhiteSpace ) do
  517.       Inc( iFront );
  518.    while ( iBack > iFront ) and ( sTrim[ iBack ] in WhiteSpace ) do
  519.       Dec( iBack );
  520.    Result := Copy( sTrim, iFront, iBack - iFront + 1 );
  521. end; { AllTrim() }
  522.  
  523. function FCreate(                { Create/overwrite a file }
  524.    sFile    : string;            { Name of file to create }
  525.    wMode    : word               { File creation mode }
  526.    )        : Integer;           { See FileCreate(), Rewrite(), _lcreate() }
  527. var
  528.    szFile : array [ 0..255 ] of char;
  529. begin
  530.    StrPCopy( szFile, sFile );
  531.    Result := _lcreat( szFile, wMode );
  532. end; { FCreate() }
  533.  
  534. function StringInSet(            { Is every character of string in set? }
  535.    sInput   : string;            { String to test every character of }
  536.    cSet     : CharSet            { Set of all potential characters }
  537.    )        : boolean;           { Return True if all chars in set }
  538. var
  539.    iPos,
  540.    iLen     : integer;
  541. begin
  542.    Result   := True;
  543.    iPos     := 1;
  544.    iLen     := Length( sInput );
  545.    while ( Result ) and ( iPos <= iLen ) do begin
  546.       Result := sInput[ iPos ] in cSet;
  547.       Inc( iPos, 1 );
  548.    end; { while }
  549. end; { StringInSet() }
  550.  
  551. function IsSymbol(               { Is this a valid symbol name? }
  552.    sInput   : string             { String to test }
  553.    )        : boolean;
  554. begin
  555.    Result := ( sInput[ 1 ] in [ '_', 'A'..'Z' ] ) and
  556.       ( StringInSet( sInput, [ '0'..'9', '_', 'A'..'Z', 'a'..'z' ] ) );
  557. end; { IsSymbol() }
  558.  
  559. function RAny( sCharSet, sSource : string; iStart : Integer ) : Integer;
  560. var
  561.    iPos : Integer;
  562.  
  563. begin
  564.    if iStart > 0 then
  565.       iPos := iStart
  566.    else
  567.       iPos := Length( sSource );
  568.    while ( iPos > 0 ) and ( Pos( sSource[ iPos ], sCharSet ) = 0 ) do
  569.       Dec( iPos );
  570.    Result := iPos;
  571. end; { RAny() }
  572.  
  573. function ExtractFileFirst( sFile : string ) : string;
  574. var
  575.    iStart, iStop : Integer;
  576.  
  577. begin
  578.    iStart := RAny( ':\', sFile, 0 );
  579.    iStop  := RAny( '.', sFile, 0 );
  580.    if ( iStop = 0 ) or ( iStart > iStop ) then iStop := Length( sFile );
  581.    Result := Copy( sFile, iStart + 1, iStop - iStart - 1 );
  582. end; { ExtractFileFirst() }
  583.  
  584. { End miscellaneous utility functions }
  585.  
  586. function ReverseBytes(                 { Swap silly FoxPro byte-reversed longints }
  587.     lVal            : longint            { Value to swap }
  588.     )                : longint;
  589. var
  590.     pVal    : array [ 0..3 ] of byte;
  591.     iTemp    : byte;
  592. begin
  593.  
  594.    Move( lVal, pVal, SizeOf( lVal ) );
  595.  
  596.    iTemp         := pVal[ 0 ];
  597.    pVal[ 0 ]     := pVal[ 3 ];
  598.    pVal[ 3 ]    := iTemp;
  599.    iTemp           := pVal[ 1 ];
  600.    pVal[ 1 ]    := pVal[ 2 ];
  601.    pVal[ 2 ]    := iTemp;
  602.  
  603.    Move( pVal, lVal, SizeOf( lVal ) );   
  604.    Result        := lVal;
  605. end; { ReverseBytes() }
  606.  
  607. function dbHeaderRead(           { Read in a header from a file }
  608.    sFile       : string;         { Name of file to read }
  609.    var Header;                   { Header structure to read }
  610.    iSize       : smallint         { Size of header structure }
  611.    )           : boolean;        { True if read successfully }
  612. var
  613.    iHandle  : smallint;
  614. begin
  615.    Result := False;
  616.    try
  617.       iHandle := FileOpen( sFile, FO_READ );
  618.       if iHandle > -1 then
  619.          if FileRead( iHandle, Header, iSize ) = iSize then
  620.             Result := True;
  621.    finally
  622.       FileClose( iHandle );
  623.    end; { try .. finally }
  624. end; { dbHeaderRead() }
  625.  
  626. function TDBField.GetName : string;
  627. begin
  628.    Result := sName;
  629. end; { TDBField.GetName }
  630.  
  631. procedure TDBField.SetName( sNew : string );
  632. begin
  633.    sNew := UpperCase( AllTrim( sNew ) );
  634.    if IsSymbol( sNew ) then
  635.       sName := sNew
  636.    else
  637.       Raise EXbFormatError.Create( 'Bad field name: "' + sNew + '"' );
  638. end; { TDBField.SetName() }
  639.  
  640. function TDBField.GetType : char;
  641. begin
  642.    Result := cType;
  643. end; { TDBField.GetType }
  644.  
  645. procedure TDBField.SetType( cNew : char );
  646. begin
  647.    cNew := UpCase( cNew );
  648.    if cNew in DBFFieldTypes then begin
  649.       cType := cNew;
  650.       if not ( cType in [ 'F', 'N' ] ) then
  651.          iDecimal := 0;
  652.       case cNew of
  653.       'D'   : iLength := 8;
  654.       'L'   : iLength := 1;
  655.       'B',
  656.       'G',
  657.       'M'   : iLength := 10;
  658.       end; { case }
  659.    end { valid type designator }
  660.    else
  661.       Raise EXbFormatError.Create( 'Bad field type: "' + cNew + '"' );
  662. end; { TDBField.SetType() }
  663.  
  664. function TDBField.GetLength : smallint;
  665. begin
  666.    Result := iLength;
  667. end; { TDBField.GetLength }
  668.  
  669. procedure TDBField.SetLength( iNew : smallint );
  670. var
  671.    iLow,
  672.    iHigh : smallint;
  673. begin
  674.    iLow := 1;
  675.    case cType of { Q: verify appropriate type lengths }
  676.    'C' : iHigh := 32733;
  677.    'D' :
  678.       begin
  679.          iLow := 8;
  680.          iHigh := 8;
  681.       end;
  682.    'F' : iHigh := 20; { Q: Is this correct? }
  683.    'L' : iHigh := 1;
  684.    'B',
  685.    'G',
  686.    'P',
  687.    'M' :
  688.       begin
  689.          iLow := 10;
  690.          iHigh := 10;
  691.       end;
  692.    'N' : iHigh := 19;
  693.    'I' : iHigh := 4;
  694.    end; { case }
  695.    if ( iLow <= iNew ) and ( iNew <= iHigh ) then
  696.       iLength := iNew
  697.    else
  698.       Raise EXbFormatError.Create(
  699.          AllTrim( IntToStr( iNew ) ) + ' is a bad field length for a '
  700.          + TypeWord + ' field' );
  701. end; { TDBField.SetLength() }
  702.  
  703. function TDBField.GetDecimal : smallint;
  704. begin
  705.    Result := iDecimal;
  706. end; { TDBField.GetDecimal }
  707.  
  708. procedure TDBField.SetDecimal( iNew : smallint );
  709. begin
  710.    if ( iNew = 0 ) or ( ( cType in [ 'N', 'F' ] ) and ( iNew > 0 ) and
  711.       ( iNew < iLength - 2 ) ) then
  712.       iDecimal := iNew
  713.    else
  714.       Raise EXbFormatError.Create(
  715.          'Bad decimal length:  Not numeric field, or too long' );
  716. end; { TDBField.SetDecimal() }
  717.  
  718. function TDBField.TypeWord : string;
  719. begin
  720.    case cType of
  721.    'B'   : Result := 'Binary (or FoxPro Double)';
  722.    'C'   : Result := 'Character';
  723.    'D'   : Result := 'Date';
  724.    'F'   : Result := 'Floating point';
  725.    'G'   : Result := 'General or OLE';
  726.    'I'   : Result := 'smallint';
  727.    'L'   : Result := 'Logical';
  728.    'M'   : Result := 'Memo';
  729.    'N'   : Result := 'Numeric';
  730.    'P'   : Result := 'Picture';
  731.    'T'   : Result := 'DateTime';
  732.    'V'   : Result := 'Varifield';
  733.    'Y'   : Result := 'Currency';
  734.    else
  735.       Result := 'Unknown';
  736.    end; { case }
  737. end; { TDBField.TypeWord }
  738.  
  739. function TDBField.IsMemo : boolean;
  740. begin
  741.    Result := ( cType in [ 'B', 'G', 'M' ] );
  742. end; { TDBField.IsMemo }
  743.  
  744. function TDBField.Header : DBFieldRec;
  745. begin
  746.    with Result do begin
  747.       FillChar( Result, SizeOf( Result ), 0 );
  748.       StrPCopy( szName, FieldName );
  749.       cFieldType := cType;
  750.       if cType = 'C' then
  751.          wCharLen := FieldLength
  752.       else begin
  753.          iLength  := FieldLength;
  754.          iDecimal := FieldDecimal;
  755.       end; { not character type }
  756.    end; { with Result }
  757. end; { TDBField.Header }
  758.  
  759. constructor TDBField.Create(      { Create the field entry }
  760.    sFieldName     : string;       { Name of the field }
  761.    cFieldType     : char;         { Character type code for the field }
  762.    iFieldLength   : smallint;      { Length of the field }
  763.    iFieldDecimal  : smallint       { Decimal precision for numeric fields }
  764.    );
  765. begin
  766.    inherited Create;
  767.    try
  768.       FieldName      := sFieldName;
  769.       FieldType      := cFieldType;
  770.       FieldLength    := iFieldLength;
  771.       FieldDecimal   := iFieldDecimal;
  772.    except
  773.       on E : EXbFormatError do
  774.          ShowMessage( E.Message );
  775.    end; { try .. except }
  776. end; { TDBField.Create() }
  777.  
  778. function TDBStruct.GetBlockSize : smallint;
  779. begin
  780.    if iBlockSize = 0 then
  781.       case TableType of
  782.       xbDB3 : Result := 512;
  783.       xbDB4 : Result := 1024;
  784.       xbFPT : Result := 32;
  785.       xbSMT : Result := 1;
  786.       else Result := 0;
  787.       end { case }
  788.    else
  789.       Result := iBlockSize;
  790. end; { TDBStruct.GetBlockSize }
  791.  
  792. procedure TDBStruct.SetBlockSize(       { Set the block size }
  793.    iNew : smallint );
  794. var
  795.    iLow,
  796.    iHigh : smallint;
  797. begin
  798.    case TableType of
  799.    xbDB3 :
  800.       begin
  801.          iLow := 512;
  802.          iHigh := 512;
  803.       end;
  804.    xbDB4 :
  805.       begin
  806.          iLow := 512;
  807.          iHigh := 1024;
  808.       end;
  809.    else
  810.       begin
  811.          iLow := 1;
  812.          iHigh := 32000;
  813.       end; { else }
  814.    end; { case }
  815.    if ( iNew > 0 ) and ( iNew < 32000 ) then
  816.       iBlockSize := iNew
  817.    else
  818.       Raise EXbFormatError.Create( 'Acceptable BlockSize range is ' +
  819.          IntToStr( iLow ) + '..' + IntToStr( iHigh ) );
  820. end;
  821.  
  822. constructor TDBStruct.Create;
  823. begin
  824.    inherited Create;
  825.    bEncrypt    := False;
  826.    iBlockSize  := 0;
  827. end; { TDBStruct.Create }
  828.  
  829. function TDBStruct.GetField( Index: smallint ): TDBField;
  830. begin
  831.    Result := TDBField( inherited Get( Index - 1 ) ); { Convert to 0-based }
  832. end; { TDBStruct.GetField() }
  833.  
  834. procedure TDBStruct.PutField( Index : smallint; oField : TDBField );
  835. begin
  836.    inherited Put( Index - 1, @oField );
  837. end; { TDBStruct.PutField() }
  838.  
  839. procedure TDBStruct.Free; { Free all objects created for Directory services }
  840. var
  841.    iField   : smallint;
  842. begin
  843.    for iField := 1 to Count do
  844.       Fields[ iField ].Free;
  845.    inherited Free;
  846. end; { TDBStruct.Free }
  847.  
  848. procedure TDBStruct.Eval(           { Do something to every field entry }
  849.    cbProc      : xbBlockProc        { Procedure "code block" type }
  850.    );
  851. var
  852.    iField : smallint;
  853. begin
  854.    for iField := 1 to Count do
  855.       with Fields[ iField ] do
  856.          cbProc( [ FieldName, FieldType, FieldLength, FieldDecimal ] );
  857. end; { TDBStruct.Eval }
  858.  
  859. function DBFileType(             { DBF File Type }
  860.    iSignature  : byte            { Signature byte }
  861.    )           : string;
  862. begin
  863.    case iSignature of
  864.    _DBF_FOXBASE      : Result := 'FoxBase, no memo';
  865.     _DBF_NO_MEMO        : Result := 'dBASE III+';
  866.     _DBF_ENCRYPT        : Result := 'Apollo encrypted, no memo';
  867.    _DBF_VFP          : Result := 'Visual FoxPro';
  868.    _DBF_DB4_SQL      : Result := 'dBASE IV SQL table, no memo';
  869.    _DBF_DB4_SQLSYS   : Result := 'dBASE IV SQL system file, no memo';
  870.     _DBF_DBT_MEMO      : Result := 'CA-Clipper/dBASE III+ .DBT memo';
  871.     _DBF_DBT_ENCRYPT    : Result := 'Apollo encrypted, no memo';
  872.     _DBF_DB4_MEMO        : Result := 'dBASE IV .DBT memo';
  873.    _DBF_DB4_SQLMEMO  : Result := 'dBASE IV SQL table, memo';
  874.     _DBF_SMT_MEMO        : Result := 'HiPer SIx with memo';
  875.     _DBF_SMT_ENCRYPT    : Result := 'HiPer SIx with memo, encrypted';
  876.     _DBF_FPT_MEMO        : Result := 'FoxPro .FPT memo';
  877.     _DBF_FPT_ENCRYPT    : Result := 'Apollo encrypted, FoxPro memo';
  878.    _DBF_FOX_MEMO     : Result := 'FoxBASE memo';
  879.    else                 Result := 'Unrecognized DBF file type';
  880.    end; { case }
  881. end; { DBFileType() }
  882.  
  883. function TDBStruct.TableType : xbMemoType;
  884. begin
  885.    sDriver := UpperCase( sDriver );
  886.    Result := xbDB3;
  887.    if ( Length( sDriver ) = 0 ) or ( sDriver = 'DEFAULT' )
  888.       or ( sDriver = 'SIXNTX' ) or ( sDriver = 'DBFNTX' ) then
  889.       Result := xbDB3   { Clipper DBF is encoded the same }
  890.    else if ( sDriver = 'DBASE' ) or ( sDriver = 'DBFMDX' ) then
  891.       Result := xbDB4
  892.    else if ( sDriver = 'SIXCDX' ) or ( sDriver = 'SIXFOX' )
  893.       or ( sDriver = 'DBFCDX' ) then
  894.       Result := xbFPT
  895.    else if ( sDriver = 'SIXNSX' ) or ( sDriver = 'DBFNSX' ) then
  896.       Result := xbSMT;
  897. end; { TDBStruct.TableType() }
  898.  
  899. function TDBStruct.Signature : byte;
  900. type
  901.    xbMatrixType   = array [ xbDB3..xbSMT, False..True ] of byte;
  902.  
  903. const
  904.    xbMatrix : xbMatrixType = (
  905.       ( _DBF_DBT_MEMO, _DBF_DBT_ENCRYPT ),
  906.       ( _DBF_DB4_MEMO, _DBF_DB4_MEMO ),
  907.       ( _DBF_FPT_MEMO, _DBF_FPT_ENCRYPT ),
  908.       ( _DBF_SMT_MEMO, _DBF_SMT_ENCRYPT ) );
  909.  
  910. var
  911.    xbDriver : xbMemoType;
  912.  
  913. begin
  914.    Result := _DBF_NO_MEMO;
  915.    try
  916.       xbDriver := TableType;
  917.       if HasMemo then
  918.          Result := xbMatrix[ xbDriver, bEncrypt ]
  919.       else if bEncrypt then
  920.          Result := _DBF_ENCRYPT;
  921.    except
  922.       Result := _DBF_NO_MEMO;
  923.    end;
  924. end; { TDBStruct.Signature }
  925.  
  926. function TDBStruct.HasMemo : boolean;   { Is there a memo field in the DBF? }
  927. var
  928.    iField   : smallint;
  929.  
  930. begin
  931.    Result := False;
  932.    for iField := 1 to Count do
  933.       if Fields[ iField ].IsMemo then begin
  934.          Result := True;
  935.          break;
  936.       end;
  937. end; { TDBStruct.HasMemo }
  938.  
  939. function TDBStruct.DataOffset : smallint; { Position of first record in file }
  940. begin
  941.    Result := SizeOf( DBFHeaderRec ) + Count * SizeOf( DBFieldRec ) + 1;
  942. end; { TDBStruct.DataOffset }
  943.  
  944. function TDBStruct.RecordLength : smallint; { # of bytes per record }
  945. var
  946.    iField   : smallint;
  947. begin
  948.    Result := 1;
  949.    for iField := 1 to Count do
  950.       Result := Result + Fields[ iField ].FieldLength;
  951. end; { TDBStruct.RecordLength }
  952.  
  953. function TDBStruct.MakeMemoHeader(  { Write a memo header structure to file }
  954.    sFile    : string;               { Name of memo file }
  955.    const Header;                    { Header structure to write }
  956.    iSize    : longint               { Size of header structure }
  957.    )        : boolean;              { True if successful }
  958. var
  959.    iPadSize,
  960.    iHandle  : smallint;
  961.    cWipe    : char;
  962. begin
  963.    Result := False;
  964.    try
  965.       iHandle := FileCreate( sFile );
  966.       if iHandle > -1 then begin
  967.          Result   := FileWrite( iHandle, Header, iSize ) = iSize;
  968.          cWipe    := #0;
  969.          iPadSize := BlockSize;
  970.          while ( iSize < iPadSize ) and ( Result ) do begin
  971.             Result := FileWrite( iHandle, cWipe, 1 ) = 1;
  972.             Inc( iSize, 1 );
  973.          end; { while }
  974.       end; { file created }
  975.       if not Result then
  976.          Raise EXbFormatError.Create( 'Could not create memo file ' + sFile );
  977.    finally
  978.       FileClose( iHandle );
  979.    end; { try .. finally }
  980. end; { TDBStruct.MakeMemoHeader() }
  981.  
  982. function TDBStruct.MakeDBT3(        { Create dBASE III+/CA-Clipper memo file }
  983.    sFile    : string                { Name of DBF file }
  984.    )        : boolean;
  985. var
  986.    recMemo  : DBT3HeaderRec;
  987.    iSize    : smallint;
  988. begin
  989.    try
  990.       iSize := SizeOf( recMemo );
  991.       FillChar( recMemo, iSize, 0 );
  992.       recMemo.lBlocks := 1;
  993.       Result := MakeMemoHeader( ChangeFileExt( sFile, '.DBT' ), recMemo,
  994.          iSize );
  995.    except
  996.       Result := False;
  997.    end;
  998. end; { TDBStruct.MakeDBT3() }
  999.  
  1000. function TDBStruct.MakeDBT4(        { Create dBASE IV and up memo file }
  1001.    sFile    : string                { Name of DBF file }
  1002.    )        : boolean;
  1003. var
  1004.    recMemo  : DBT4HeaderRec;
  1005.    iSize    : smallint;
  1006. begin
  1007.    try
  1008.       iSize := SizeOf( recMemo );
  1009.       FillChar( recMemo, iSize, 0 );
  1010.       with recMemo do begin
  1011.          lNextBlock  := 1;          { Next free block to be used }
  1012.          lCurBlockSz := 0;
  1013.          StrPCopy( szDBFName, UpperCase( ExtractFileFirst( sFile ) ) );
  1014.          wVersion    := _DBT4_VERSION;
  1015.          wBlockSize  := BlockSize;  { Block size being used, in bytes }
  1016.          bEncrypted  := bEncrypt;   { Is file encrypted? }
  1017.       end; { with RecMemo }
  1018.  
  1019.       Result := MakeMemoHeader( ChangeFileExt( sFile, '.DBT' ), recMemo,
  1020.          iSize );
  1021.    except
  1022.       Result := False;
  1023.    end;
  1024. end; { TDBStruct.MakeDBT4() }
  1025.  
  1026. function TDBStruct.MakeSMT(      { Create a HiPer SIx memo file }
  1027.    sFile    : string             { Name of DBF file }
  1028.    )        : boolean;
  1029. var
  1030.    recMemo  : SMTHeaderRec;
  1031.    iSize    : smallint;
  1032. begin
  1033.    try
  1034.       iSize := SizeOf( recMemo );
  1035.       FillChar( recMemo, iSize, 0 );
  1036.       with recMemo do begin
  1037.          lBlockSize := BlockSize; { Block size being used, in bytes }
  1038.          if lBlockSize > 512 then
  1039.             lNextBlock := 1  { Next free block to be used }
  1040.          else
  1041.             lNextBlock := 512 div lBlockSize;
  1042.       end; { with recMemo }
  1043.       Result := MakeMemoHeader( ChangeFileExt( sFile, '.SMT' ), recMemo,
  1044.          iSize );
  1045.    except
  1046.       Result := False;
  1047.    end;
  1048. end; { TDBStruct.MakeSMT() }
  1049.  
  1050. function TDBStruct.MakeFPT(      { Create a FoxPro memo file }
  1051.    sFile    : string             { Name of DBF file }
  1052.    )        : boolean;
  1053. var
  1054.    recMemo  : FPTHeaderRec;
  1055.    iSize    : smallint;
  1056. begin
  1057.    try
  1058.       iSize := SizeOf( recMemo );
  1059.       FillChar( recMemo, iSize, 0 );
  1060.       with recMemo do begin
  1061.          lBlockSize := BlockSize; { Block size being used, in bytes }
  1062.          if lBlockSize > 512 then
  1063.             lNextBlock := 1  { Next free block to be used }
  1064.          else
  1065.             lNextBlock := 512 div lBlockSize;
  1066.          lNextBlock   := ReverseBytes( lNextBlock );
  1067.          lBlockSize   := ReverseBytes( lBlockSize );
  1068.       end; { with recMemo }
  1069.       Result := MakeMemoHeader( ChangeFileExt( sFile, '.FPT' ), recMemo,
  1070.          iSize );
  1071.    except
  1072.       Result := False;
  1073.    end;
  1074. end; { TDBStruct.MakeFPT() }
  1075.  
  1076. function TDBStruct.MakeMemo(     { Create memo file if necessary }
  1077.    sFile    : string             { DBF file name }
  1078.    )        : boolean;           { True if successful }
  1079. begin
  1080.    try
  1081.       case Signature of
  1082.        _DBF_DBT_MEMO     : Result := MakeDBT3( sFile );
  1083.        _DBF_DB4_MEMO        : Result := MakeDBT4( sFile );
  1084.        _DBF_SMT_MEMO,
  1085.        _DBF_SMT_ENCRYPT    : Result := MakeSMT( sFile );
  1086.        _DBF_FPT_MEMO,
  1087.        _DBF_FPT_ENCRYPT    : Result := MakeFPT( sFile );
  1088.       else                 Result := True;
  1089.       end; { case }
  1090.    except
  1091.       Result := False;
  1092.    end; { try .. except }
  1093. end; { TDBStruct.MakeMemo() }
  1094.  
  1095. function TDBStruct.Make(         { Create the DBF file }
  1096.    sFile    : string             { DBF file name }
  1097.    )        : boolean;           { True if successful }
  1098. const
  1099.    DBF_END_FIELDS : array [ 0..1 ] of char = #13+#26;
  1100.  
  1101. var
  1102.    recDBF      : DBFHeaderRec;
  1103.    recField    : DBFieldRec;
  1104.    wYear,
  1105.    wMonth,
  1106.    wDay        : word;
  1107.    iField,
  1108.    iHandle     : smallint;
  1109.    dNow        : TDateTime;
  1110.  
  1111. begin
  1112.    Result := False;
  1113.    try
  1114.       iHandle  := fCreate( sFile, FC_NORMAL );
  1115.       if iHandle > -1 then begin
  1116.          dNow        := Date;
  1117.          DecodeDate( dNow, wYear, wMonth, wDay );
  1118.             FillChar( recDBF, SizeOf( recDBF ), 0 );
  1119.          with recDBF do begin
  1120.             iSignature  := Signature;
  1121.             iYear       := wYear - 1900;
  1122.             iMonth      := wMonth;
  1123.             iDay        := wDay;
  1124.             lRecords    := 0;
  1125.             wDataOffset := DataOffset;
  1126.             wRecLen     := RecordLength;
  1127.             iLanguage   := 27;
  1128.          end; { with recDBF }
  1129.          if FileWrite( iHandle, recDBF, SizeOf( recDBF ) ) = SizeOf( recDBF )
  1130.          then begin
  1131.             for iField := 1 to Count do begin
  1132.                recField := Fields[ iField ].Header;
  1133.                FileWrite( iHandle, recField, SizeOf( recField ) );
  1134.             end;
  1135.             FileWrite( iHandle, DBF_END_FIELDS, 2 );
  1136.             MakeMemo( sFile );
  1137.             Result := True;
  1138.          end
  1139.          else
  1140.             Raise EXbFormatError.Create( 'Could not create header for ' + sFile );
  1141.       end; { File created }
  1142.    finally
  1143.       FileClose( iHandle );
  1144.    end;
  1145. end; { TDBStruct.Make() }
  1146.  
  1147. function DBFieldCount(           { # of fields in data file }
  1148.    recDBF   : DBFHeaderRec       { Database file header }
  1149.    )        : smallint;
  1150. begin
  1151.    Result := ( recDBF.wDataOffset - SizeOf( DBFHeaderRec ) - 1 )
  1152.       div SizeOf( DBFieldRec );  { Calc the # of fields }
  1153. end; { DBFieldCount() }
  1154.  
  1155. function DBStructRead(           { Read the structure from a DBF file }
  1156.    sFile    : string
  1157.    )        : TDBStruct;
  1158. var
  1159.    recHeader   : DBFHeaderRec;
  1160.    recField    : DBFieldRec;
  1161.    iField,
  1162.    iHandle     : smallint;
  1163.    oField      : TDBField;
  1164.  
  1165. begin
  1166.    Result := nil;
  1167.    try
  1168.  
  1169.       iHandle  := FileOpen( sFile, FO_READ );
  1170.       if iHandle > -1 then
  1171.       begin
  1172.          Result := TDBStruct.Create;
  1173.          FileRead( iHandle, recHeader, Sizeof( recHeader ) );
  1174.          Result.Capacity := DBFieldCount( recHeader );
  1175.          for iField := 0 to Result.Capacity - 1 do begin
  1176.             FileRead( iHandle, recField, sizeof( recField ) );
  1177.             with recField do
  1178.                if cFieldType = 'C' then
  1179.                   oField   := TDBField.Create( StrPas( szName ), cFieldType,
  1180.                      wCharLen, 0 )
  1181.                else
  1182.                   oField   := TDBField.Create( StrPas( szName ), cFieldType,
  1183.                      iLength, iDecimal );
  1184.             Result.Add( oField );
  1185.          end; { for iField }
  1186.       end; { File Opened successfully }
  1187.  
  1188.    finally
  1189.       FileClose( iHandle );
  1190.    end; { try .. finally }
  1191. end; { DBStructRead() }
  1192.  
  1193. function dbCreateStruct(         { Convert array of const to DBStruct }
  1194.    aStruct  : array of const     { Field structure information:
  1195.                                     4 array elements per field:
  1196.                                     1. Field name (string)
  1197.                                     2. Field type (char)
  1198.                                     3. Field length (smallint)
  1199.                                     4. Field decimal (smallint) }
  1200.    ) : TDBStruct;                { Use TDBStruct.Free when done! }
  1201. var
  1202.    iField,
  1203.    iFields  : smallint;
  1204. begin
  1205.    iFields  := High( aStruct ) div 4;
  1206.    try
  1207.       Result := TDBStruct.Create;
  1208.       Result.Capacity := iFields;
  1209.       for iField := 0 to iFields do
  1210.          Result.Add( TDBField.Create(
  1211.             {$IFDEF WIN32}
  1212.             aStruct[ iField * 4 ].VPChar,
  1213.             {$ELSE}
  1214.             aStruct[ iField * 4 ].VString^,
  1215.             {$ENDIF}
  1216.             aStruct[ iField * 4 + 1 ].VChar,
  1217.             aStruct[ iField * 4 + 2 ].VInteger,
  1218.             aStruct[ iField * 4 + 3 ].VInteger ) );
  1219.    except
  1220.       on E : EXbFormatError do
  1221.          ShowMessage( E.Message );
  1222.    end; { try .. except }
  1223. end; { dbCreateStruct() }
  1224.  
  1225. {$IFNDEF XP_NO_NATIVE_DBCREATE}
  1226. function dbCreate(               { Create a data file }
  1227.    sDataFile   : string;         { Name of data file to create }
  1228.    oStruct     : TDBStruct;      { Database structure object }
  1229.     sDriver     : string;         { Name of data driver to use for creation }
  1230.    bEncrypt    : boolean         { Encrypt the file? }
  1231.    ) : boolean;
  1232. begin
  1233.    try
  1234.       if Length( sDriver ) > 0 then
  1235.          oStruct.sDriver := sDriver;
  1236.       oStruct.bEncrypt := bEncrypt;
  1237.       Result := oStruct.Make( sDataFile );
  1238.    except
  1239.       Result := False;
  1240.    end; { try .. except }
  1241. end; { dbCreate() }
  1242. {$ENDIF}
  1243.  
  1244. procedure ShowDBF(               { Show structure of an DBF file }
  1245.    sFile : string );             { Name of DBF file }
  1246. var
  1247.    recHeader : DBFHeaderRec;
  1248. begin
  1249.    if dbHeaderRead( sFile, recHeader, SizeOf( recHeader ) ) then
  1250.       with recHeader do begin
  1251.          WriteLn( 'iSignature  :', iSignature,
  1252.             ' (', DBFileType( iSignature ), ')' );
  1253.          WriteLn( 'iYear       :', iYear );
  1254.          WriteLn( 'iMonth      :', iMonth );
  1255.          WriteLn( 'iDay        :', iDay );
  1256.          WriteLn( 'lRecords    :', lRecords );
  1257.          WriteLn( 'wDataOffset :', wDataOffset );
  1258.          WriteLn( 'wRecLen     :', wRecLen );
  1259.          WriteLn( 'bIncomplete :', bIncomplete );
  1260.          WriteLn( 'bEncrypted  :', bEncrypted );
  1261.          WriteLn( 'sMultiuser  :', sMultiuser );
  1262.          WriteLn( 'iFlags      :', iFlags );
  1263.          WriteLn( 'iLanguage   :', iLanguage );
  1264.       end; { with }
  1265.  
  1266. end; { ShowDBF() }
  1267.  
  1268. procedure ShowDBT3(              { Show structure of a DBT3 file }
  1269.    sFile : string );             { Name of DBT file }
  1270. var
  1271.    recHeader : DBT3HeaderRec;
  1272. begin
  1273.    if dbHeaderRead( sFile, recHeader, SizeOf( recHeader ) ) then
  1274.       WriteLn( 'lBlocks     :', recHeader.lBlocks );
  1275. end; { ShowDBT3() }
  1276.  
  1277. procedure ShowDBT4(              { Show structure of a DBT4 file }
  1278.    sFile : string );             { Name of DBT file }
  1279. var
  1280.    recHeader : DBT4HeaderRec;
  1281. begin
  1282.    if dbHeaderRead( sFile, recHeader, SizeOf( recHeader ) ) then
  1283.       with recHeader do begin
  1284.          WriteLn( 'lNextBlock  :', lNextBlock );
  1285.          WriteLn( 'lCurBlockSz :', lCurBlockSz );
  1286.          WriteLn( 'szDBFName   :', szDBFName );
  1287.          WriteLn( 'wVersion    :', wVersion );
  1288.          WriteLn( 'wBlockSize  :', wBlockSize );
  1289.          WriteLn( 'bEncrypted  :', bEncrypted );
  1290.       end; { with }
  1291. end; { ShowDBT4() }
  1292.  
  1293. procedure ShowSMT(               { Show structure of an SMT file }
  1294.    sFile : string );             { Name of SMT file }
  1295. var
  1296.    recHeader : SMTHeaderRec;
  1297. begin
  1298.    if dbHeaderRead( sFile, recHeader, SizeOf( recHeader ) ) then
  1299.       with recHeader do begin
  1300.          WriteLn( 'lNextBlock     :', lNextBlock );
  1301.          WriteLn( 'lBlockSize  :', lBlockSize );
  1302.       end; { with }
  1303. end; { ShowSMT() }
  1304.  
  1305. procedure ShowFPT(               { Show structure of an FPT file }
  1306.    sFile : string );             { Name of FPT file }
  1307. var
  1308.    recHeader : FPTHeaderRec;
  1309. begin
  1310.    if dbHeaderRead( sFile, recHeader, SizeOf( recHeader ) ) then
  1311.       with recHeader do begin
  1312.          WriteLn( 'lNextBlock     :', ReverseBytes( lNextBlock ) );
  1313.          WriteLn( 'lBlockSize  :', ReverseBytes( lBlockSize ) );
  1314.       end; { with }
  1315. end; { ShowFPT() }
  1316.  
  1317. end.
  1318.